home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / tests / image.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  11.4 KB  |  358 lines  |  [TEXT/ALFA]
  1. # This file is a Tcl script to test out the "image" command and the
  2. # other procedures in the file tkImage.c.  It is organized in the
  3. # standard fashion for Tcl tests.
  4. #
  5. # Copyright (c) 1994 The Regents of the University of California.
  6. # Copyright (c) 1994 Sun Microsystems, Inc.
  7. #
  8. # See the file "license.terms" for information on usage and redistribution
  9. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10. #
  11. # SCCS: @(#) image.test 1.15 97/07/31 10:17:25
  12.  
  13. if {[lsearch [image types] test] < 0} {
  14.     puts "This application hasn't been compiled with the \"test\" image"
  15.     puts "type, so I can't run this test.  Are you sure you're using"
  16.     puts "tktest instead of wish?"
  17.     return
  18. }
  19.  
  20. if {[info procs test] != "test"} {
  21.     source defs
  22. }
  23.  
  24. foreach i [winfo children .] {
  25.     destroy $i
  26. }
  27. wm geometry . {}
  28. raise .
  29.  
  30. eval image delete [image names]
  31. canvas .c -highlightthickness 2
  32. pack .c
  33. update
  34. test image-1.1 {Tk_ImageCmd procedure, "create" option} {
  35.     list [catch image msg] $msg
  36. } {1 {wrong # args: should be "image option ?args?"}}
  37. test image-1.2 {Tk_ImageCmd procedure, "create" option} {
  38.     list [catch {image gorp} msg] $msg
  39. } {1 {bad option "gorp": must be create, delete, height, names, type, types, or width}}
  40. test image-1.3 {Tk_ImageCmd procedure, "create" option} {
  41.     list [catch {image create} msg] $msg
  42. } {1 {wrong # args: should be "image create type ?name? ?options?"}}
  43. test image-1.4 {Tk_ImageCmd procedure, "create" option} {
  44.     list [catch {image c bad_type} msg] $msg
  45. } {1 {image type "bad_type" doesn't exist}}
  46. test image-1.5 {Tk_ImageCmd procedure, "create" option} {
  47.     list [image create test myimage] [image names]
  48. } {myimage myimage}
  49. test image-1.6 {Tk_ImageCmd procedure, "create" option} {
  50.     scan [image create test] image%d first
  51.     image create test myimage
  52.     scan [image create test -variable x] image%d second
  53.     expr $second-$first
  54. } {1}
  55. test image-1.7 {Tk_ImageCmd procedure, "create" option} {
  56.     image delete myimage
  57.     image create test myimage -variable x
  58.     .c create image 100 50 -image myimage
  59.     .c create image 100 150 -image myimage
  60.     update
  61.     set x {}
  62.     image create test myimage -variable x
  63.     update
  64.     set x
  65. } {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}}
  66. test image-1.8 {Tk_ImageCmd procedure, "create" option} {
  67.     .c delete all
  68.     image create test myimage -variable x
  69.     .c create image 100 50 -image myimage
  70.     .c create image 100 150 -image myimage
  71.     image delete myimage
  72.     update
  73.     set x {}
  74.     image create test myimage -variable x
  75.     update
  76.     set x
  77. } {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}}
  78. test image-1.9 {Tk_ImageCmd procedure, "create" option} {
  79.     .c delete all
  80.     eval image delete [image names]
  81.     list [catch {image create test -badName foo} msg] $msg [image names]
  82. } {1 {bad option name "-badName"} {}}
  83.  
  84. test image-2.1 {Tk_ImageCmd procedure, "delete" option} {
  85.     list [catch {image delete} msg] $msg
  86. } {0 {}}
  87. test image-2.2 {Tk_ImageCmd procedure, "delete" option} {
  88.     .c delete all
  89.     eval image delete [image names]
  90.     image create test myimage
  91.     image create test img2
  92.     set result {}
  93.     lappend result [lsort [image names]]
  94.     image d myimage img2
  95.     lappend result [image names]
  96. } {{img2 myimage} {}}
  97. test image-2.3 {Tk_ImageCmd procedure, "delete" option} {
  98.     .c delete all
  99.     eval image delete [image names]
  100.     image create test myimage
  101.     image create test img2
  102.     list [catch {image delete myimage gorp img2} msg] $msg [image names]
  103. } {1 {image "gorp" doesn't exist} img2}
  104.  
  105. test image-3.1 {Tk_ImageCmd procedure, "height" option} {
  106.     list [catch {image height} msg] $msg
  107. } {1 {wrong # args: should be "image height name"}}
  108. test image-3.2 {Tk_ImageCmd procedure, "height" option} {
  109.     list [catch {image height a b} msg] $msg
  110. } {1 {wrong # args: should be "image height name"}}
  111. test image-3.3 {Tk_ImageCmd procedure, "height" option} {
  112.     list [catch {image height foo} msg] $msg
  113. } {1 {image "foo" doesn't exist}}
  114. test image-3.4 {Tk_ImageCmd procedure, "height" option} {
  115.     image create test myimage
  116.     set x [image h myimage]
  117.     myimage changed 0 0 0 0 60 50
  118.     list $x [image height myimage]
  119. } {15 50}
  120.  
  121. test image-4.1 {Tk_ImageCmd procedure, "names" option} {
  122.     list [catch {image names x} msg] $msg
  123. } {1 {wrong # args: should be "image names"}}
  124. test image-4.2 {Tk_ImageCmd procedure, "names" option} {
  125.     .c delete all
  126.     eval image delete [image names]
  127.     image create test myimage
  128.     image create test img2
  129.     image create test 24613
  130.     lsort [image names]
  131. } {24613 img2 myimage}
  132. test image-4.3 {Tk_ImageCmd procedure, "names" option} {
  133.     .c delete all
  134.     eval image delete [image names]
  135.     lsort [image names]
  136. } {}
  137.  
  138. test image-5.1 {Tk_ImageCmd procedure, "type" option} {
  139.     list [catch {image type} msg] $msg
  140. } {1 {wrong # args: should be "image type name"}}
  141. test image-5.2 {Tk_ImageCmd procedure, "type" option} {
  142.     list [catch {image type a b} msg] $msg
  143. } {1 {wrong # args: should be "image type name"}}
  144. test image-5.3 {Tk_ImageCmd procedure, "type" option} {
  145.     list [catch {image type foo} msg] $msg
  146. } {1 {image "foo" doesn't exist}}
  147. test image-5.4 {Tk_ImageCmd procedure, "type" option} {
  148.     image create test myimage
  149.     image type myimage
  150. } {test}
  151. test image-5.5 {Tk_ImageCmd procedure, "type" option} {
  152.     image create test myimage
  153.     .c create image 50 50 -image myimage
  154.     image delete myimage
  155.     image type myimage
  156. } {}
  157.  
  158. test image-6.1 {Tk_ImageCmd procedure, "types" option} {
  159.     list [catch {image types x} msg] $msg
  160. } {1 {wrong # args: should be "image types"}}
  161. test image-6.2 {Tk_ImageCmd procedure, "types" option} {
  162.     lsort [image types]
  163. } {bitmap photo test}
  164.  
  165. test image-7.1 {Tk_ImageCmd procedure, "width" option} {
  166.     list [catch {image width} msg] $msg
  167. } {1 {wrong # args: should be "image width name"}}
  168. test image-7.2 {Tk_ImageCmd procedure, "width" option} {
  169.     list [catch {image width a b} msg] $msg
  170. } {1 {wrong # args: should be "image width name"}}
  171. test image-7.3 {Tk_ImageCmd procedure, "width" option} {
  172.     list [catch {image width foo} msg] $msg
  173. } {1 {image "foo" doesn't exist}}
  174. test image-7.4 {Tk_ImageCmd procedure, "width" option} {
  175.     image create test myimage
  176.     set x [image w myimage]
  177.     myimage changed 0 0 0 0 60 50
  178.     list $x [image width myimage]
  179. } {30 60}
  180.  
  181. test image-8.1 {Tk_ImageChanged procedure} {
  182.     .c delete all
  183.     eval image delete [image names]
  184.     image create test foo -variable x
  185.     .c create image 50 50 -image foo
  186.     update
  187.     set x {}
  188.     foo changed 5 6 7 8 30 15
  189.     update
  190.     set x
  191. } {{foo display 5 6 7 8 30 30}}
  192. test image-8.2 {Tk_ImageChanged procedure} {
  193.     .c delete all
  194.     eval image delete [image names]
  195.     image create test foo -variable x
  196.     .c create image 50 50 -image foo
  197.     .c create image 90 100 -image foo
  198.     update
  199.     set x {}
  200.     foo changed 5 6 7 8 30 15
  201.     update
  202.     set x
  203. } {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}}
  204.  
  205. test image-9.1 {Tk_GetImage procedure} {
  206.     list [catch {.c create image 100 10 -image bad_name} msg] $msg
  207. } {1 {image "bad_name" doesn't exist}}
  208. test image-9.2 {Tk_GetImage procedure} {
  209.     image create test mytest
  210.     catch {destroy .l}
  211.     label .l -image mytest
  212.     image delete  mytest
  213.     set result [list [catch {label .l2 -image mytest} msg] $msg]
  214.     destroy .l
  215.     set result
  216. } {1 {image "mytest" doesn't exist}}
  217.  
  218. test image-10.1 {Tk_FreeImage procedure} {
  219.     .c delete all
  220.     eval image delete [image names]
  221.     image create test foo -variable x
  222.     .c create image 50 50 -image foo -tags i1
  223.     .c create image 90 100 -image foo -tags i2
  224.     pack forget .c
  225.     update
  226.     set x {}
  227.     .c delete i1
  228.     pack .c
  229.     update
  230.     list [image names] $x
  231. } {foo {{foo free} {foo display 0 0 30 15 103 121}}}
  232. test image-10.2 {Tk_FreeImage procedure} {
  233.     .c delete all
  234.     eval image delete [image names]
  235.     image create test foo -variable x
  236.     .c create image 50 50 -image foo -tags i1
  237.     image delete foo
  238.     update
  239.     set names [image names]
  240.     set x {}
  241.     .c delete i1
  242.     pack forget .c
  243.     pack .c
  244.     update
  245.     list $names [image names] $x
  246. } {foo {} {}}
  247.  
  248. # Non-portable, apparently due to differences in rounding:
  249.  
  250. test image-11.1 {Tk_RedrawImage procedure, redisplay area clipping} \
  251.     {nonPortable} {
  252.     .c delete all
  253.     eval image delete [image names]
  254.     image create test foo -variable x
  255.     .c create image 50 60 -image foo -tags i1 -anchor nw
  256.     update
  257.     .c create rectangle 30 40 55 65 -width 0 -fill black -outline {}
  258.     set x {}
  259.     update
  260.     set x
  261. } {{foo display 0 0 5 5 50 50}}
  262. test image-11.2 {Tk_RedrawImage procedure, redisplay area clipping} \
  263.     {nonPortable} {
  264.     .c delete all
  265.     eval image delete [image names]
  266.     image create test foo -variable x
  267.     .c create image 50 60 -image foo -tags i1 -anchor nw
  268.     update
  269.     .c create rectangle 60 40 100 65 -width 0 -fill black -outline {}
  270.     set x {}
  271.     update
  272.     set x
  273. } {{foo display 10 0 20 5 30 50}}
  274. test image-11.3 {Tk_RedrawImage procedure, redisplay area clipping} \
  275.     {nonPortable} {
  276.     .c delete all
  277.     eval image delete [image names]
  278.     image create test foo -variable x
  279.     .c create image 50 60 -image foo -tags i1 -anchor nw
  280.     update
  281.     .c create rectangle 60 70 100 200 -width 0 -fill black -outline {}
  282.     set x {}
  283.     update
  284.     set x
  285. } {{foo display 10 10 20 5 30 30}}
  286. test image-11.4 {Tk_RedrawImage procedure, redisplay area clipping} \
  287.     {nonPortable} {
  288.     .c delete all
  289.     eval image delete [image names]
  290.     image create test foo -variable x
  291.     .c create image 50 60 -image foo -tags i1 -anchor nw
  292.     update
  293.     .c create rectangle 30 70 55 200 -width 0 -fill black -outline {}
  294.     set x {}
  295.     update
  296.     set x
  297. } {{foo display 0 10 5 5 50 30}}
  298. test image-11.5 {Tk_RedrawImage procedure, redisplay area clipping} \
  299.     {nonPortable} {
  300.     .c delete all
  301.     eval image delete [image names]
  302.     image create test foo -variable x
  303.     .c create image 50 60 -image foo -tags i1 -anchor nw
  304.     update
  305.     .c create rectangle 10 20 120 130 -width 0 -fill black -outline {}
  306.     set x {}
  307.     update
  308.     set x
  309. } {{foo display 0 0 30 15 70 70}}
  310. test image-11.6 {Tk_RedrawImage procedure, redisplay area clipping} \
  311.     {nonPortable} {
  312.     .c delete all
  313.     eval image delete [image names]
  314.     image create test foo -variable x
  315.     .c create image 50 60 -image foo -tags i1 -anchor nw
  316.     update
  317.     .c create rectangle 55 65 75 70 -width 0 -fill black -outline {}
  318.     set x {}
  319.     update
  320.     set x
  321. } {{foo display 5 5 20 5 30 30}}
  322.  
  323. test image-12.1 {Tk_SizeOfImage procedure} {
  324.     eval image delete [image names]
  325.     image create test foo -variable x
  326.     set result [list [image width foo] [image height foo]]
  327.     foo changed 0 0 0 0 85 60
  328.     lappend result [image width foo] [image height foo]
  329. } {30 15 85 60}
  330.  
  331. test image-12.2 {DeleteImage procedure} {
  332.     .c delete all
  333.     eval image delete [image names]
  334.     image create test foo -variable x
  335.     .c create image 50 50 -image foo -tags i1
  336.     .c create image 90 100 -image foo -tags i2
  337.     set x {}
  338.     image delete foo
  339.     lappend x | [image names] |
  340.     image delete foo
  341.     lappend x | [image names] |
  342. } {{foo free} {foo free} {foo delete} | foo | | foo |}
  343.  
  344. catch {image delete hidden}
  345. set l [image names]
  346. set h [interp hidden]
  347.  
  348. test image-13.1 {image command vs hidden commands} {
  349.     catch {image delete hidden}
  350.     image create photo hidden
  351.     interp hide {} hidden
  352.     image delete hidden
  353.     list [image names] [interp hidden]
  354. } [list $l $h]
  355.     
  356. destroy .c
  357. eval image delete [image names]
  358.